home *** CD-ROM | disk | FTP | other *** search
/ Magazyn WWW 1999 July / www_07_1999.iso / prog / mac / alpha / alpha.hqx / Alpha ƒ / Tcl / SystemCode / alphaCommands.tcl < prev    next >
Text File  |  1999-03-19  |  6KB  |  246 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "alphaCommands.tcl"
  6.  #                                    created: 03/18/1998 {01:13:44 AM} 
  7.  #                                last update: 19/3/99 {9:26:19 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: vince@biosgroup.com
  10.  #    mail: Bios Group
  11.  #          617 Paseo de Peralta, Santa Fe, NM 87501
  12.  #     www: http://www.biosgroup.com/
  13.  #  
  14.  # Copyright (c) 1998 Vince Darley
  15.  # 
  16.  # All rights reserved.
  17.  # 
  18.  # See the file "license.terms" for information on usage and redistribution of
  19.  # this file, and for a DISCLAIMER OF ALL WARRANTIES.
  20.  #  
  21.  #  Description: 
  22.  # 
  23.  #   Mostly procedures which would really help Alpha if they were
  24.  #   hard-coded.  Some other procedures for convenience are here too.
  25.  #  History
  26.  # 
  27.  #  modified by  rev reason
  28.  #  -------- --- --- -----------
  29.  #  03/18/19 VMD 1.0 original
  30.  # ###################################################################
  31.  ##
  32.  
  33. if {${alpha::platform} != "alpha"} {
  34.     alertnote "Shouldn't load this code"
  35.     return
  36. }
  37.  
  38. namespace eval tmark {}
  39.  
  40. ## 
  41.  # -------------------------------------------------------------------------
  42.  # 
  43.  # "tmark::getPos" --
  44.  # 
  45.  #  This procedure is pretty slow, due to limitations in Alpha.  Hopefully
  46.  #  one day we'll have a hard-wired quick version.  It also works around
  47.  #  a bug in which Alpha tells us that windows which aren't files (e.g.
  48.  #  just created with 'new -n') are located in Alpha's 'pwd' directory.
  49.  #  
  50.  #  The stupid thing is that Alpha knows exactly where each stop is, but
  51.  #  it won't tell us!  'gotoTMark $m' goes to exactly the position we
  52.  #  want, but we can't find it out some other way.
  53.  # -------------------------------------------------------------------------
  54.  ##
  55. if {[info tclversion] < 8.0} {
  56.     proc tmark::getPos {m {f ""}} {
  57.     if {$f == ""} {set f [win::Current]}
  58.     regsub { <[0-9]+>$} $f "" f
  59.     if {[file exists $f]} {
  60.         if {[regexp "\{$m \{[quote::Regfind $f]\} (\[0-9\]+) \[0-9\]+\}" [getTMarks] "" where]} {
  61.         return $where
  62.         }
  63.     } else {
  64.         if {[regexp "\{$m \{[quote::Regfind [pwd]$f]\} (\[0-9\]+) \[0-9\]+\}" [getTMarks] "" where]} {
  65.         return $where
  66.         }
  67.     }
  68.     error "No such mark"
  69.     }
  70. } else {
  71.     proc tmark::getPos {m {f ""}} { 
  72.     if {$f == ""} {
  73.         return [lindex [getPosOfTMark $m] 0] 
  74.     } else {
  75.         return [lindex [getPosOfTMark -w $f $m] 0] 
  76.     }
  77.     }
  78.  
  79. }
  80. if {[info tclversion] < 8.0} {
  81.     proc tmark::getRange {m {f ""}} {
  82.     if {$f == ""} {set f [win::Current]}
  83.     regsub { <[0-9]+>$} $f "" df
  84.     if {[file exists $df]} {
  85.         if {[regexp "\{ \{$m\} \{[quote::Regfind $df]\} (\[0-9\]+ \[0-9\]+ \[0-9\]+) \}" [getNamedMarks -w $f] "" where]} {
  86.         return $where
  87.         }
  88.     } else {
  89.         if {[regexp "\{ \{$m\} \{[quote::Regfind [pwd]$df]\} (\[0-9\]+ \[0-9\]+ \[0-9\]+) \}" [getNamedMarks -w $f] "" where]} {
  90.         return $where
  91.         }
  92.     }
  93.     error "No such mark"
  94.     }
  95. } else {
  96.     proc tmark::getRange {m {f ""}} { 
  97.     if {$f == ""} {
  98.         return [getPosOfTMark $m]
  99.     } else {
  100.         return [getPosOfTMark -w $f $m]
  101.     }
  102.     }
  103.  
  104. }
  105. namespace eval mark {}
  106. if {[info tclversion] < 8.0} {
  107.     proc mark::getRange {m {f ""}} {
  108.     if {$f == ""} {set f [win::Current]}
  109.     regsub { <[0-9]+>$} $f "" df
  110.     if {[file exists $df]} {
  111.         if {[regexp "\{ \{$m\} \{[quote::Regfind $df]\} (\[0-9\]+ \[0-9\]+ \[0-9\]+)" [getNamedMarks -w $f] "" where]} {
  112.         return $where
  113.         }
  114.     } else {
  115.         if {[regexp "\{ \{$m\} \{[quote::Regfind [pwd]$df]\} (\[0-9\]+ \[0-9\]+ \[0-9\]+)" [getNamedMarks -w $f] "" where]} {
  116.         return $where
  117.         }
  118.     }
  119.     error "No such mark"
  120.     }
  121. } else {
  122.     proc mark::getRange {m {f ""}} { 
  123.     if {$f == ""} {
  124.         return [getPosOfMark $m]
  125.     } else {
  126.         return [getPosOfMark -w $f $m]
  127.     }
  128.     }
  129.  
  130. }
  131.  
  132. ## 
  133.  # -------------------------------------------------------------------------
  134.  # 
  135.  # "tmark::getPositions" --
  136.  # 
  137.  #  For speed you can ask for a bunch of positions at once.
  138.  # -------------------------------------------------------------------------
  139.  ##
  140. if {[info tclversion] < 8.0} {
  141.     proc tmark::getPositions {mm} {
  142.     regexp {(.*) <[0-9]+>$} [set f [win::Current]] "" f
  143.     if {[file exists $f]} {
  144.         set reg " \{[quote::Regfind $f]\} (\[0-9\]+) \[0-9\]+\}"
  145.     } else {
  146.         set reg " \{[quote::Regfind [pwd]$f]\} (\[0-9\]+) \[0-9\]+\}"
  147.     }
  148.     set marks [getTMarks]
  149.     foreach m $mm {
  150.         if {[regexp "\{$m$reg" $marks "" where]} {
  151.         lappend res $where
  152.         } else {
  153.         error "No such mark"
  154.         }
  155.     }
  156.     return $res
  157.     }
  158. } else {
  159.     proc tmark::getPositions {mm} {
  160.     foreach m $mm {
  161.         lappend res [lindex [getPosOfTMark $m] 0]
  162.     }
  163.     return $res
  164.     }
  165. }
  166.  
  167. if {[info tclversion] < 8.0} {
  168.  
  169. proc tmark::isAt {p} {
  170.     regexp {(.*) <[0-9]+>$} [set f [win::Current]] "" f
  171.     if {[file exists $f]} {
  172.     if {[regexp "\{(stop\[0-9\]+:\[0-9\]+) \{[quote::Regfind $f]\} $p $p\}" [getTMarks] "" which]} {
  173.         return $which
  174.     }
  175.     } else {
  176.     if {[regexp "\{(stop\[0-9\]+:\[0-9\]+) \{[quote::Regfind [pwd]$f]\} $p $p\}" [getTMarks] "" which]} {
  177.         return $which
  178.     }
  179.     }
  180.     return ""
  181. }
  182.  
  183. } else {
  184.     proc tmark::isAt {p} { return [isTMarkAt $p] }
  185. }
  186.  
  187. # Thanks to Johan Linde:
  188. proc refresh {{w ""}} {
  189.     if {$w == ""} {
  190.     eval sizeWin [lrange [getGeometry] 2 end]
  191.     } else {
  192.     eval sizeWin [list $w] [lrange [getGeometry $w] 2 end]
  193.     }
  194. }
  195.  
  196.  
  197. namespace eval text {}
  198.  
  199. proc text::hyper {from to hyper} {
  200.     text::color $from $to 15 $hyper
  201. }
  202.  
  203. proc text::color {from to colour {hyper ""}} {
  204.     if {$colour > 7} {
  205.     if {$colour == 15} {
  206.         insertColorEscape $from $colour $hyper
  207.     } else {
  208.         insertColorEscape $from $colour
  209.     }
  210.     insertColorEscape $to 12
  211.     } else {
  212.     insertColorEscape $from $colour
  213.     insertColorEscape $to 0
  214.     }
  215. }
  216.  
  217. namespace eval status {}
  218.  
  219. proc status::prompt {prompt {func ""} {type "key"}} {
  220.     global status::proc status::add
  221.     set status::proc $func
  222.     set status::add $type
  223.     return [uplevel [list statusPrompt $prompt status::helper]]
  224. }
  225.  
  226. proc status::helper {args} {
  227.     global status::add status::proc
  228.     switch -- ${status::add} {
  229.     "modifiers" -
  230.     "anything" {
  231.         lappend args [getModifiers]
  232.     } 
  233.     }
  234.     return [uplevel ${status::proc} $args]
  235. }
  236.  
  237. namespace eval pos {}
  238.  
  239. proc pos::compare {args} {uplevel expr $args}
  240. proc pos::math {args} {uplevel expr $args}
  241. proc minPos {} { return 0 }
  242.  
  243.  
  244.  
  245.  
  246.